home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / 4cmp22o.zip / FILTER.4TH < prev    next >
Text File  |  1994-08-13  |  5KB  |  147 lines
  1. \ FILTER INTERFACE
  2. 0 #IF
  3. COPYRIGHT 1985 (C) BY THOMAS ALMY.  ALL RIGHTS RESERVED
  4. Revision copyright 1991 (C) by Thomas Almy.
  5.  
  6. Permission is granted to registered users of ForthCMP to sell or distribute
  7. computer programs incorporating the compiled contents of this file.
  8.  
  9. VARS and DOS1 must be INCLUDED from the main program
  10.  
  11. User functions are SETFILES, BYE, ABORT, CONSOLE, FILTER,
  12.   KEY, EMIT, EXPECT, SETBUFS and the variable OPTIONSTRING.
  13.   DO NOT use PRINTER and/or MESSAGES (latter is "CONSOLE" here)
  14. SDEFSTR, DDEFSTR, and BUFSIZ tailor the program for
  15.   specific applications.
  16. See UNLOAD.4TH and LIST.4TH for examples of use.
  17. #THEN
  18.  
  19. \ FILTER SUPORT -- EMITS
  20. 10 DECIMAL    .( LOADING FILTER ) CR
  21. FIND BUFSIZ #IF DROP #ELSE 512 CONSTANT BUFSIZ #THEN
  22. FIND TIB #IF DROP #ELSE INCLUDE VARS #THEN
  23. FIND stdin #IF DROP #ELSE INCLUDE DOS1 #THEN
  24. HCB outfile     ( when file is set )
  25. DSEG stdout outfile !  ( set to default to STD-OUTPUT )
  26. VARIABLE outhandle ( handle to use on output )
  27. DSEG stderr outhandle !  ( initially the display )
  28. VARIABLE outbuffer  ( pointer to allocated buffer )
  29. VARIABLE outbufptr
  30. 0 0 IN/OUT 
  31. : flushout   outbuffer @ outbufptr @ <> IF
  32.  outhandle @ outbuffer @ outbufptr @ outbuffer @ - DUP >R write
  33.  outbuffer @ outbufptr ! R> <> IF  stderr outhandle !
  34.    ." DISK FULL " flushout 4 RETURN THEN THEN ;
  35.  
  36. : EMIT  outbufptr @ DUP outbuffer @ BUFSIZ + = IF flushout
  37.    DROP outbuffer @ THEN C! 1 outbufptr +! ;
  38. 0 0 IN/OUT : CONSOLE flushout stderr outhandle ! ;
  39. 0 0 IN/OUT : FILTER  flushout outfile HCB>H outhandle ! ;
  40.  
  41. 1 0 IN/OUT : bye2 ( errorCode -- )
  42.   flushout  stdout outfile @ <> IF ( file to close )
  43.      outfile FCLOSE DROP THEN  RETURN ;
  44. 0 0 IN/OUT : BYE  0 bye2 ;
  45. 0 0 IN/OUT : ABORT 4 bye2 ;
  46.  
  47.  
  48. \ LOW LEVEL INTERFACE -- INPUT
  49. VARIABLE inbuffer  ( pointer to allocated buffer )
  50. VARIABLE inbufptr  VARIABLE inbufend
  51. HCB infile
  52. stdin infile !    \ default
  53.  
  54. 0 0 IN/OUT
  55. : SETBUFS  ( must execute before any I/O to allocate buffers )
  56.   HERE inbuffer !
  57.   BUFSIZ ALLOT
  58.   HERE DUP outbuffer ! outbufptr !
  59.   BUFSIZ ALLOT ;
  60.  
  61.  
  62. \ LOW LEVEL INTERFACE -- KEY AND EXPECT
  63. \ This version of KEY returns -1 on end of file!
  64. : KEY  inbufptr @ inbufend @ = IF ( fetch block )
  65.     infile @ inbuffer @ BUFSIZ read ?DUP 0= IF ( EOF/ERROR ) -1  EXIT THEN
  66.     inbuffer @ + inbufend !  inbuffer @ inbufptr ! THEN
  67.   inbufptr @ C@  1 inbufptr +!  ;
  68. \ This version of EXPECT sets SPAN to -1 if end of file!
  69. : EXPECT ( buffer count -- )  DUP SPAN !
  70.     0 DO   BEGIN KEY DUP CONTROL M = WHILE DROP REPEAT
  71.          DUP 0< IF SPAN ON DROP LEAVE THEN
  72.          DUP CONTROL Z = IF SPAN ON DROP LEAVE THEN
  73.          DUP CONTROL J = IF  I SPAN ! DROP LEAVE THEN
  74.          OVER C! 1+ LOOP DROP ;
  75.  
  76. \ STRING COMPARISON UTILITY WORD
  77. PRIMITIVE
  78. : S= ( string1 string2 length -- flag, true if equal )
  79.   >R  -1 -ROT  R> 0 ?DO
  80.       OVER I + C@  OVER I + C@
  81.            <> IF  ROT DROP 0 -ROT LEAVE THEN
  82.       LOOP
  83.   2DROP ;
  84.  
  85.  
  86. \ SHOULD BACKUP FILE IF SAME
  87. 0 1 IN/OUT : ?samefile  ( -- failflag )
  88.     infile HCB>N outfile HCB>N DUP C@ 1+ S= IF
  89.         ( files are same -- indicate error and abort )
  90.         ." SOURCE AND DESTINATION FILES IDENTICAL "
  91.         -1 ELSE 0 THEN  ;
  92.  
  93. \ SETUP OPTIONS
  94. SEPDSEG? CONSTANT ?dseg
  95. 0 0 IN/OUT : setcommand ( set up for command parsing )
  96.   ?dseg #IF ?CS: 129 ?DS: TIB 127 CMOVEL #ELSE
  97.             129 TIB 127 CMOVE #THEN
  98.   128 CS: C@ #TIB !  >IN OFF ( read args from TIB ) ;
  99. 2VARIABLE OPTIONSTRING
  100. 0 0 IN/OUT : setoptions  ( get option string, if any )
  101.   BL WORD C@ 1 > IF HERE 1+ C@ ASCII - = IF ( got one! )
  102.      >IN @ HERE C@ - TIB +  DUP 1- C@ ASCII - <> IF 1+ THEN
  103.      HERE C@ 1- OPTIONSTRING 2!   BL WORD DROP EXIT  THEN THEN
  104.      0. OPTIONSTRING 2! ; 
  105. 0 #IF
  106. A pointer to the options string, and its length, is in the
  107. 2VARIABLE "OPTIONSTRING".  The value is valid until the next
  108. query.
  109. #THEN
  110.  
  111. \ SET IN DEFAULT EXTENSIONS
  112. FIND SDEFSTR #IF DROP #ELSE  0 CONSTANT SDEFSTR  #THEN
  113. FIND DDEFSTR #IF DROP #ELSE  0 CONSTANT DDEFSTR  #THEN
  114. SDEFSTR DDEFSTR OR #IF
  115. 2 0 IN/OUT
  116. : setext  ( hcb extension -- )
  117.   SWAP HCB>N DUP >R  1+  ( ext string )
  118.   BEGIN COUNT DUP ASCII . = IF DROP BEGIN COUNT DUP 0=
  119.         IF R> 2DROP 2DROP EXIT THEN  ASCII \ = UNTIL  1 THEN
  120.         0= UNTIL
  121.   DUP 1- ASCII . C<-  ( replace null with dot )
  122.   SWAP COUNT 0 ?DO COUNT 2 PICK C! SWAP 1+ SWAP LOOP
  123.   DROP ( extension address )
  124.   DUP 0 C<-  ( delimit string )
  125.   R@ - 1- R> C!   ( set length byte )
  126.   ;  #THEN
  127.  
  128. \ MAJOR OPEN DRIVE FUNCTION
  129. 0 1 IN/OUT : SETFILES ( -- failureflag )
  130.   setcommand setoptions
  131.   HERE C@ 0= IF  0 FILTER EXIT THEN
  132.   HERE @ ASCII - 8 << 1 + <> IF ( input file )
  133.         -1 infile !
  134.           HERE infile NAME>HCB
  135.           SDEFSTR #IF infile SDEFSTR setext #THEN
  136.           infile O_RD FOPEN IF infile .FNAME ." not found"
  137.                                    -1 EXIT THEN  THEN
  138.   BL WORD C@ IF HERE @ ASCII - 8 << 1 + <> IF ( output file )
  139.         -1 outfile !
  140.           HERE outfile NAME>HCB
  141.           DDEFSTR #IF outfile DDEFSTR setext #THEN
  142.           ?samefile IF -1 EXIT THEN
  143.           outfile 0 FMAKE IF ." cannot create " outfile
  144.                               .FNAME -1 EXIT  THEN
  145.    THEN THEN   0  FILTER ;
  146. HEX 0A = #IF DECIMAL #THEN
  147.